home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / sources.lha / sources / sys / unix_port.t < prev    next >
Text File  |  1988-02-12  |  8KB  |  266 lines
  1. (herald unix_port
  2.         (env tsys (osys vm_port) (osys buffer)))
  3.  
  4. ;;; The Unix interface to the file system.
  5.  
  6.  
  7. ;;; Unix stat blocks
  8.  
  9. ;++ make this a foreign structure someday
  10. (define (make-stat-block)
  11.   (make-bytev 64))
  12.  
  13. (lset *stat-block-pool* (make-pool 'stat-block-pool make-stat-block 1 bytev?))
  14.  
  15. (define-integrable (allocate-stat-block)
  16.   (obtain-from-pool *stat-block-pool*))
  17.  
  18. (define-integrable (release-stat-block obj)
  19.   (return-to-pool *stat-block-pool* obj))
  20.  
  21. (comment
  22. ;++ test this and decide if it is worth using?
  23. (define-local-syntax (with-pathnames specs . body)
  24.   (cond ((every? valid-spec? specs)
  25.          `(let (,@(map (lambda (spec)
  26.                          (cond ((atom? (cdr spec))
  27.                                 `(,(car spec)
  28.                                    (get-string-buffer-of-size 128))
  29.                                (unix-expand-path
  30.                                 (string->asciz! (filename->string
  31.                                                 (->filename ,(cdr spec))))
  32.                                 ,(car spec)))
  33.                                (else
  34.                                 (syntax-error
  35.                                  "illegal spec~%  ~S"
  36.                                  `(with-stat-blocks ,specs . ,body)))))
  37.                        specs))
  38.             (unwind-protect
  39.               (block ,@body)
  40.               ,@(map (lambda (spec)
  41.                        `(release-string-buffer ,(car spec)))
  42.                      specs))))
  43.         (syntax-error "illegal spec~%  ~S"
  44.                       `(with-stat-blocks ,specs . ,body))))
  45. )
  46.  
  47. (define-local-syntax (with-stat-blocks specs . body)
  48.   (cond ((every? valid-spec? specs)
  49.          `(let (,@(map (lambda (spec)
  50.                          (cond ((atom? (cdr spec))
  51.                                 `(,(car spec) (allocate-stat-block)))
  52.                                (else
  53.                                 (syntax-error
  54.                                  "illegal spec~%  ~S"
  55.                                  `(with-stat-blocks ,specs . ,body)))))
  56.                        specs))
  57.             (unwind-protect
  58.               (block ,@body)
  59.               ,@(map (lambda (spec)
  60.                        `(release-stat-block ,(car spec)))
  61.                      specs))))
  62.         (syntax-error "illegal spec~%  ~S"
  63.                       `(with-stat-blocks ,specs . ,body))))
  64.  
  65.  
  66.  
  67. (define (file-attributes filespec)
  68.   (let* ((path (->pathname filespec))
  69.          (stat-block (allocate-stat-block)))
  70.     (cond ((fx> 0 (unix-stat path stat-block))  
  71.            (release-string-buffer path)
  72.            (return nil nil nil nil))
  73.           (else
  74.            (release-string-buffer path)
  75.            (return t
  76.                    (st_mtime stat-block)
  77.                    (st_size  stat-block)
  78.                    (st_mode  stat-block))))))
  79.  
  80. (define-foreign unix-stat (stat (in rep/string)
  81.                                 (in rep/extend))
  82.                 rep/integer)
  83.  
  84. (define (FILE-PROBE filespec)
  85.   (with-open-ports ((iob (maybe-open filespec 'inquire)))
  86.     (if iob (expand-filename iob) '#f)))
  87.  
  88. (define (expand-filename filespec)
  89.   (with-open-ports ((iob (maybe-open filespec 'inquire)))
  90.     (if iob (->filename (port-truename iob)) (->filename filespec))))
  91.  
  92. (define port-truename
  93.   (lambda (iob)
  94.     (let* ((buf (get-string-buffer-of-size 120))
  95.            (filespec (iob-id iob))                        
  96.            (str (string->asciz! 
  97.                  (cond ((string?   filespec) filespec)
  98.                        ((not (file-system-present?))
  99.                         (error "Filespecs must be strings in VM."))
  100.                        ((filename? filespec) (filename->string filespec))
  101.                        (else
  102.                         (filename->string (->filename filespec)))))))
  103.       (set (string-length buf) 120)
  104.       (unix-expand-path str buf)
  105.       (set (string-length buf) (string-posq #\null buf))
  106.       (let ((val (copy-string buf)))
  107.         (release-string-buffer buf)
  108.         val))))
  109.  
  110. ;;; EXPAND-FILENAME (internal-routine) - move to fs_parse
  111. ;;; Returns an expanded Unix filename.
  112.  
  113. ;;; If the file exists FILE-PROBE returns the truename of the
  114. ;;; file, otherwise, it returns false.
  115.  
  116. ;(define (file-probe fname)
  117. ;  (let ((fname (->pathname fname)))
  118. ;    (with-stat-blocks ((stat-block))
  119. ;      (cond ((fx> 0 (unix-stat fname stat-block))
  120. ;             nil)
  121. ;            (else (->filename fname))))))
  122.  
  123. ;+++ bogus version for the moment, doesn't handle networks.
  124. (define (file-move from to)
  125.   (let ((from (->pathname from))
  126.         (to   (->pathname to)))
  127.     (check-status (unix-file-link from to))
  128.     (check-status (unix-file-unlink from))
  129.     (release-string-buffer from)
  130.     (release-string-buffer to)
  131.     (no-value)))
  132.  
  133. (define-foreign unix-file-link (link (in rep/string)
  134.                                          (in rep/string))
  135.                 rep/integer)
  136.  
  137. (define (file-delete fname)
  138.   (let ((path (->pathname fname)))
  139.     (if (fx> 0 (unix-file-unlink path))
  140.         (local-os-error nil))
  141.     (release-string-buffer path)
  142.     (no-value)))
  143.  
  144.  
  145. (define-foreign r-unix-unlink
  146.   (unlink (in rep/string filename))
  147.   rep/integer)
  148.  
  149. (define-integrable (unix-file-unlink filename)
  150.   (r-unix-unlink (string->asciz! (copy-string filename))))
  151.  
  152. (define-unimplemented (FILE-TRUNCATE iob SIZE))
  153.  
  154. ;;; In the next five calls SPEC can be either a filespec or an iob.
  155. ;;; If they cannot be implemented they should return nil.
  156.  
  157. (define (FILE-CREATION-DATE spec)
  158.   (receive (dtc #f #f #f)
  159.            (file-attributes spec)
  160.     dtc))
  161.  
  162. ;++ internal time??
  163. (define (file-write-date spec)
  164.   (receive (status dtu #f #f)
  165.            (file-attributes spec)
  166.     (if status dtu (file-write-date (error "File not found ~S" spec)))))
  167.  
  168. (define (FILE-USED-DATE SPEC)
  169.   (receive (#f #f dtu #f)
  170.            (file-attributes spec)
  171.     dtu))
  172.  
  173.  
  174. (define (file-newer? fname1 fname2)
  175.   (> (file-write-date fname1) (file-write-date fname2)))
  176.  
  177. ;++ is this useful? as is?
  178. (define (file-length fname)
  179.   (with-stat-blocks ((stat-block))
  180.     (let ((path (->pathname fname)))
  181.       (cond ((fx> 0 (unix-stat path stat-block))
  182.              (local-os-error nil))
  183.             (else
  184.              (release-string-buffer path)
  185.              (st_size stat-block))))))
  186.  
  187. (define (file-directory? fname)
  188.   (with-stat-blocks ((stat-block))
  189.     (let ((path (->pathname fname)))
  190.       (cond ((fx> 0 (unix-stat path stat-block))
  191.              (release-string-buffer path)
  192.              nil)
  193.           (else
  194.            (release-string-buffer path)
  195.            (fxN= 0 (fixnum-logand (st_mode stat-block) #o040000)))))))
  196.  
  197. ;;; Working directory
  198.  
  199. (define working-directory
  200.   (object (lambda ()
  201.           (let* ((buf (make-string 1024))
  202.              (val (unix-getwd buf)))
  203.             (cond ((fx= 0 val)
  204.                    (error "~a" buf))
  205.                   (else
  206.                    (set (string-length buf)
  207.                     (string-posq #\null buf))
  208.                    (->filename buf)))))
  209.     ((setter self)
  210.      (lambda (xpath)
  211.        (let ((path (->pathname xpath)))
  212.          (cond ((fx> 0 (unix-chdir path))
  213.                 (local-os-error nil))
  214.                (else path)))))))
  215.  
  216.  
  217. (define-foreign r-unix-chdir
  218.   (chdir (in rep/string dirname))
  219.   rep/integer)
  220.  
  221. (define-integrable (unix-chdir dirname)
  222.   (r-unix-chdir (string->asciz! (copy-string dirname))))
  223.  
  224. (define-foreign unix-getwd (getwd (in rep/string))
  225.                 rep/integer)
  226.  
  227. (define (home-directory)
  228.   (unix-getenv "HOME"))
  229.  
  230. (define-unimplemented (naming-directory))
  231.  
  232. (comment
  233.  (define NAMING-DIRECTORY
  234.   (let ((name (->pathname (copy-string "."))))
  235.     (object (lambda () name)
  236.       ((setter self)
  237.        (lambda (filespec)
  238.          (cond ((file-directory? filespec)
  239.                 (set name (->filename filespec))
  240.                 (no-value))
  241.                (else
  242.                 (error "filespec ~s must be a directory" filespec))))))))
  243. )
  244. ;++ Someday, the following ought to be settable.
  245.  
  246.  
  247. (define-foreign r-unix-getenv
  248.   (getenv (in rep/string name))
  249.   rep/pointer)
  250.  
  251. (define (unix-getenv name)
  252.   (let ((val (r-unix-getenv (string->asciz! name))))
  253.        (if (fx= val 0)
  254.        '#f
  255.        (asciz->string val))))
  256.  
  257.  
  258. ;;; Returns the login name as a string.
  259. (define (user-name)
  260.   (let ((val (unix-getlogin)))
  261.     (cond ((fx= val 0) nil)
  262.           (else (asciz->string val)))))
  263.  
  264. (define-foreign unix-getlogin (getlogin)
  265.                 rep/pointer)
  266.